home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmpflet.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
11KB
|
308 lines
;;; CMPFLET Flet, Labels, and Macrolet.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(si:putprop 'flet 'c1flet 'c1special)
(si:putprop 'flet 'c2flet 'c2)
(si:putprop 'labels 'c1labels 'c1special)
(si:putprop 'labels 'c2labels 'c2)
(si:putprop 'macrolet 'c1macrolet 'c1special)
;;; c2macrolet is not defined, because MACROLET is replaced by PROGN
;;; during Pass 1.
(si:putprop 'call-local 'c2call-local 'c2)
(defstruct fun
name ;;; Function name.
ref ;;; Referenced or not.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the
;;; function closure, or NIL.
ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the
;;; function closure, or NIL.
cfun ;;; The cfun for the function.
level ;;; The level of the function.
)
(defvar *funs* nil)
;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions
;;; and the symbol 'CB' (Closure Boundary). 'CB' will be pushed on *funs*
;;; when the compiler begins to process a closure. A local macro definition
;;; is a list ( macro-name expansion-function).
(defun c1flet (args &aux body ss ts is other-decl info
(defs1 nil) (local-funs nil) (closures nil))
(when (endp args) (too-few-args 'flet 1 0))
(let ((*funs* *funs*))
(dolist** (def (car args))
(cmpck (or (endp def)
(not (symbolp (car def)))
(endp (cdr def)))
"The function definition ~s is illegal." def)
(let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
(push fun *funs*)
(push (list fun (cdr def)) defs1)))
(multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
(let ((*vars* *vars*))
(c1add-globals ss)
(check-vdecl nil ts is)
(setq body (c1decl-body other-decl body)))
(setq info (copy-info (cadr body))))
(dolist* (def (reverse defs1))
(when (fun-ref-ccb (car def))
(let ((*vars* (cons 'cb *vars*))
(*funs* (cons 'cb *funs*))
(*blocks* (cons 'cb *blocks*))
(*tags* (cons 'cb *tags*)))
(let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
(add-info info (cadr lam))
(push (list (car def) lam) closures))))
(when (fun-ref (car def))
(let ((*blocks* (cons 'lb *blocks*))
(*tags* (cons 'lb *tags*))
(*vars* (cons 'lb *vars*)))
(let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
(add-info info (cadr lam))
(push (list (car def) lam) local-funs))))
(when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
(setf (fun-cfun (car def)) (next-cfun)))
)
(if (or local-funs closures)
(list 'flet info (reverse local-funs) (reverse closures) body)
body)
)
(defun c2flet (local-funs closures body
&aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
(dolist** (def local-funs)
(setf (fun-level (car def)) *level*)
(push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))
;;; Setup closures.
(dolist** (def closures)
(push (list 'closure
(if (null *clink*) nil (cons 0 0))
*ccb-vs* (car def) (cadr def))
*local-funs*)
(push (car def) *closures*)
(let ((fun (car def)))
(declare (object fun))
(setf (fun-ref fun) (vs-push))
(wt-nl)
(wt-vs (fun-ref fun))
(wt "=make_cclosure(LC" (fun-cfun fun) ",Cnil,") (wt-clink)
(wt ",Cdata,Cstart,Csize);")
(wt-nl)
(wt-vs (fun-ref fun))
(wt "=MMcons(") (wt-vs (fun-ref fun)) (wt ",") (wt-clink) (wt ");")
(clink (fun-ref fun))
(setf (fun-ref-ccb fun) (ccb-vs-push))
))
(c2expr body)
)
(defun c1labels (args &aux body ss ts is other-decl info
(defs1 nil) (local-funs nil) (closures nil)
(fnames nil) (processed-flag nil) (*funs* *funs*))
(when (endp args) (too-few-args 'labels 1 0))
;;; bind local-functions
(dolist** (def (car args))
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
"The local function definition ~s is illegal." def)
(cmpck (member (car def) fnames)
"The function ~s was already defined." (car def))
(push (car def) fnames)
(let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
(push fun *funs*)
(push (list fun nil nil (cdr def)) defs1)))
(setq defs1 (reverse defs1))
;;; Now DEFS1 holds ( { ( fun-object NIL NIL body ) }* ).
(multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
(let ((*vars* *vars*))
(c1add-globals ss)
(check-vdecl nil ts is)
(setq body (c1decl-body other-decl body)))
(setq info (copy-info (cadr body)))
(block local-process
(loop
(setq processed-flag nil)
(dolist** (def defs1)
(when (and (fun-ref (car def)) ;;; referred locally and
(null (cadr def))) ;;; not processed yet
(setq processed-flag t)
(setf (cadr def) t)
(let ((*blocks* (cons 'lb *blocks*))
(*tags* (cons 'lb *tags*))
(*vars* (cons 'lb *vars*)))
(let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
(add-info info (cadr lam))
(push (list (car def) lam) local-funs)))))
(unless processed-flag (return-from local-process))
)) ;;; end local process
(block closure-process
(loop
(setq processed-flag nil)
(dolist** (def defs1)
(when (and (fun-ref-ccb (car def)) ; referred across closure
(null (caddr def))) ; and not processed
(setq processed-flag t)
(setf (caddr def) t)
(let ((*vars* (cons 'cb *vars*))
(*funs* (cons 'cb *funs*))
(*blocks* (cons 'cb *blocks*))
(*tags* (cons 'cb *tags*)))
(let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
(add-info info (cadr lam))
(push (list (car def) lam) closures))))
)
(unless processed-flag (return-from closure-process))
)) ;;; end closure process
(dolist** (def defs1)
(when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
(setf (fun-cfun (car def)) (next-cfun))))
(if (or local-funs closures)
(list 'labels info (reverse local-funs) (reverse closures) body)
body)
)
(defun c2labels (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*))
;;; Prepare for cross-referencing closures.
(dolist** (def closures)
(let ((fun (car def)))
(declare (object fun))
(setf (fun-ref fun) (vs-push))
(wt-nl)
(wt-vs (fun-ref fun))
(wt "=MMcons(Cnil,") (wt-clink) (wt ");")
(clink (fun-ref fun))
(setf (fun-ref-ccb fun) (ccb-vs-push))
))
(dolist** (def local-funs)
(setf (fun-level (car def)) *level*)
(push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))
;;; Then make closures.
(dolist** (def closures)
(push (list 'closure (if (null *clink*) nil (cons 0 0))
*ccb-vs* (car def) (cadr def))
*local-funs*)
(push (car def) *closures*)
(wt-nl)
(wt-vs* (fun-ref (car def)))
(wt "=make_cclosure(LC" (fun-cfun (car def)) ",Cnil,") (wt-clink)
(wt ",Cdata,Cstart,Csize);")
)
;;; now the body of flet
(c2expr body)
)
(defun c1macrolet (args &aux body ss ts is other-decl
(*funs* *funs*) (*vars* *vars*))
(when (endp args) (too-few-args 'macrolet 1 0))
(dolist** (def (car args))
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
"The macro definition ~s is illegal." def)
(push (list (car def)
(caddr (si:defmacro* (car def) (cadr def) (cddr def))))
*funs*))
(multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
(c1add-globals ss)
(check-vdecl nil ts is)
(c1decl-body other-decl body)
)
(defun c1local-fun (fname &aux (ccb nil))
(declare (object ccb))
(dolist* (fun *funs* nil)
(cond ((eq fun 'CB) (setq ccb t))
((consp fun)
(when (eq (car fun) fname) (return (cadr fun))))
((eq (fun-name fun) fname)
(if ccb
(setf (fun-ref-ccb fun) t)
(setf (fun-ref fun) t))
(return (list 'call-local *info* fun ccb)))))
)
(defun sch-local-fun (fname)
;;; Returns fun-ob for the local function (not locat macro) named FNAME,
;;; if any. Otherwise, returns FNAME itself.
(dolist* (fun *funs* fname)
(when (and (not (eq fun 'CB))
(not (consp fun))
(eq (fun-name fun) fname))
(return fun)))
)
(defun c1local-closure (fname &aux (ccb nil))
(declare (object ccb))
;;; Called only from C1FUNCTION.
(dolist* (fun *funs* nil)
(cond ((eq fun 'CB) (setq ccb t))
((consp fun)
(when (eq (car fun) fname) (return (cadr fun))))
((eq (fun-name fun) fname)
(setf (fun-ref-ccb fun) t)
(return (list 'call-local *info* fun ccb)))))
)
(defun c2call-local (fd args &aux (*vs* *vs*))
;;; FD is a list ( fun-object ccb ).
(cond
((cadr fd)
(push-args args)
(wt-nl "cclosure_call(") (wt-ccb-vs (fun-ref-ccb (car fd))) (wt ");"))
((and (listp args)
*do-tail-recursion*
*tail-recursion-info*
(eq (car *tail-recursion-info*) (car fd))
(eq *exit* 'RETURN)
(tail-recursion-possible)
(= (length args) (length (cdr *tail-recursion-info*))))
(let* ((*value-to-go* 'trash)
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2psetq (mapcar #'(lambda (v) (list v nil))
(cdr *tail-recursion-info*))
args)
(wt-label *exit*))
(unwind-no-exit 'tail-recursion-mark)
(wt-nl "goto TTL;")
(cmpnote "Tail-recursive call of ~s was replaced by iteration."
(fun-name (car fd))))
(t (push-args args)
(wt-nl "L" (fun-cfun (car fd)) "(")
(dotimes** (n (fun-level (car fd))) (wt "base" n ","))
(wt "base")
(unless (= (fun-level (car fd)) *level*) (wt (1- *level*)))
(wt ");")
(base-used)))
(unwind-exit 'fun-val)
)